home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / ada / adaed-1.11 / adaed-1 / Adaed-1.11.0a / libw.c < prev    next >
Encoding:
C/C++ Source or Header  |  1992-02-07  |  48.8 KB  |  1,764 lines
  1. /*
  2.  * Copyright (C) 1985-1992  New York University
  3.  * 
  4.  * This file is part of the Ada/Ed-C system.  See the Ada/Ed README file for
  5.  * warranty (none) and distribution info and also the GNU General Public
  6.  * License for more details.
  7.  
  8.  */
  9.  
  10. /* libw - procedures for writing (in C format) ais and tre files*/
  11.  
  12. #ifdef __GNUG__
  13. extern "C"
  14. {
  15. #include <sys/types.h>
  16. #include <sys/dir.h>
  17. }
  18. #endif
  19. #include "hdr.h"
  20. #include "vars.h"
  21. #include "libhdr.h"
  22. #include "ifile.h"
  23. #include "setprots.h"
  24. #include "dbxprots.h"
  25. #include "miscprots.h"
  26. #include "smiscprots.h"
  27. #include "chapprots.h"
  28. #include "libprots.h"
  29. #include "libfprots.h"
  30. #include "libwprots.h"
  31.  
  32. #ifdef BSD
  33. /* Needed for cleanup_files routine */
  34. #include <sys/types.h>
  35. #include <sys/dir.h>
  36. #endif
  37.  
  38. #ifdef SYSTEM_V
  39. /* Needed for cleanup_files routine */
  40. #include <fcntl.h>
  41. #include <sys/types.h>
  42. #include <sys/dir.h>
  43. #endif
  44.  
  45. #ifdef IBM_PC
  46. #include <dos.h>
  47. #include <errno.h>
  48. #endif
  49.  
  50. #ifdef vms
  51. /* Needed for cleanup_files routine */
  52. #include descrip
  53. #include rmsdef
  54. #endif
  55.  
  56. extern char *LIBRARY_PREFIX;
  57. extern IFILE *TREFILE, *AISFILE, *STUBFILE, *LIBFILE;
  58.  
  59. static void putlitmap(IFILE *, Symbol);
  60. static void putnod(IFILE *, char *, Node);
  61. static void putnodref(IFILE *, char *, Node);
  62. static void putint(IFILE *, char *, int );
  63. static void putlong(IFILE *, char *, long);
  64. static void putmisc(IFILE *, Symbol);
  65. static void putrepr(IFILE *, Symbol);
  66. static void putunt(IFILE *, char *, unsigned int);
  67. static void putnval(IFILE *, Node);
  68. static void putuint(IFILE *, char *, int *);
  69. static void putovl(IFILE *, Symbol);
  70. static void putsig(IFILE *, Symbol);
  71. static void putsym(IFILE *, char *, Symbol);
  72. static void putudecl(IFILE *, int);
  73. static long write_next(IFILE *);
  74. static void put_unit_unam(IFILE *, Symbol);
  75.  
  76. void putdcl(IFILE *ofile, Declaredmap d)                        /*;putdcl*/
  77. {
  78.     Fordeclared fd;
  79.     char    *id;
  80.     Symbol    sym;
  81.     int        i, n = 0;
  82.     typedef struct {
  83.         char *iden;
  84.         short sym_seq;
  85.         short sym_unit;
  86.         short visible;
  87.     }f_dmap_s;
  88.     f_dmap_s ** dptrs;
  89.     f_dmap_s *    filedmap;
  90.     f_dmap_s *    save_filedmap;
  91.  
  92.     if (d == (Declaredmap)0) {
  93.         putnum(ofile, "putdcl-is-map-defined", 0);
  94.         return;
  95.     }
  96.     putnum(ofile, "putdcl-is-map-defined", 1); /* to indicate map defined */
  97.     n = 0; /* count number of entries where defined */
  98.     FORDECLARED(id, sym, d, fd);
  99.         n += 1;
  100.     ENDFORDECLARED(fd);
  101.     putnum(ofile, "putdcl-number-defined", n);
  102.     if (n == 0) return;
  103.     save_filedmap = filedmap = (f_dmap_s *)
  104.       ecalloct((unsigned)n, sizeof(f_dmap_s), "put-dcl-save-filedmap");
  105.     dptrs =
  106.       (f_dmap_s **) emalloct(sizeof(f_dmap_s *) * (unsigned)n, "put-dcl-dptrs");
  107.     n = 0;
  108.     FORDECLARED(id, sym, d, fd);
  109.         n++;  /* number of entries seen so far */
  110.         filedmap->iden = id;
  111.         if (sym == (Symbol) 0)
  112.             filedmap->sym_seq = filedmap->sym_unit = 0;
  113.         else {
  114.             filedmap->sym_seq = S_SEQ(sym);
  115.             filedmap->sym_unit = S_UNIT(sym);
  116.         }
  117.         filedmap->visible = IS_VISIBLE(fd);
  118.         /* now, insert pointer to new record such that ids are sorted 
  119.          * this is necessary (for debugging only!) to ensure entries appear
  120.          * in the same order each time the declared map is written
  121.          */
  122.         i = n-1;
  123.         while ( i > 0 && strcmp(filedmap->iden, dptrs[i-1]->iden) < 0) {
  124.             dptrs[i] = dptrs[i-1];
  125.             i--;
  126.         }
  127.         dptrs[i] = filedmap;
  128.         filedmap++;
  129.     ENDFORDECLARED(fd);
  130.  
  131.     /* now, write to file */
  132.     for (i = 0; i < n; i++ ) {
  133.         putstr(ofile, "str", dptrs[i]->iden);
  134.         putnum(ofile, "seq", dptrs[i]->sym_seq);
  135.         putnum(ofile, "unt", dptrs[i]->sym_unit);
  136.         putnum(ofile, "vis", dptrs[i]->visible);
  137. #ifdef IOT
  138.         if (iot_ais_w == 1)
  139.             printf("  %s %d %d %d\n", dptrs[i]->iden, dptrs[i]->sym_seq,
  140.               dptrs[i]->sym_unit, dptrs[i]->visible);
  141. #endif
  142.     }
  143.     efreet((char *)save_filedmap, "putdcl-save-filedmap");
  144.     efreet((char *) dptrs, "putdcl-dptrs");
  145. }
  146.  
  147. static void putlitmap(IFILE *ofile, Symbol sym)                /*;putlitmap*/
  148. {
  149.     /* called for na_enum to output literal map.
  150.      * The literal map is a tuple, entries consisting of string followed
  151.      * by integer.
  152.      */
  153.  
  154.     Tuple    tup;
  155.     int i, n;
  156.  
  157.     tup = (Tuple) OVERLOADS(sym);
  158.     n = tup_size(tup);
  159.     putnum(ofile, "litmap-n", n);
  160.     for (i = 1; i <= n; i += 2) {
  161.         putstr(ofile, "litmap-str", tup[i]);
  162.         putnum(ofile, "litmap-value", (int) tup[i+1]);
  163.     }
  164. }
  165.  
  166. static void putnod(IFILE *ofile, char *desc, Node node)                /*;putnod*/
  167. {
  168.     /* Write information for the node to a file (ofile)
  169.      * Since all the nodes in the tree all have the same N_UNIT value, 
  170.      * the node can be written to the file in a more compact format.
  171.      * The N_UNIT of the node itself and of its children (N_AST1...) need not
  172.      * be written out only their N_SEQ filed needs to be written out. There
  173.      * is one complication of this scheme. OPT_NODE which is (seq=1,unit=0) will
  174.      * conflict with (seq=1,unit=X)  of current unit. Therefore, in this case a 
  175.      * sequence # of -1 will signify OPT_NODE.
  176.      */
  177.  
  178.     Tuple    tup;
  179.     Fortup    ft1;
  180.     int     has_n_list = 0;
  181.     int        nk;
  182.     Node    nod;
  183.     short    fnum[24];
  184.     int        fnums = 0;
  185.     Symbol    sym;
  186.  
  187. #ifdef DEBUG
  188.     if (trapns>0 && N_SEQ(node) == trapns && N_UNIT(node) == trapnu)trapn(node);
  189. #endif
  190.     /* copy standard info */
  191.     nk = N_KIND(node);
  192.     fnum[fnums++] = nk;
  193.     fnum[fnums++] = N_SEQ(node);
  194.     if (N_LIST_DEFINED(nk)) {
  195.         tup = N_LIST(node);
  196.         if (tup == (Tuple)0) 
  197.             has_n_list = 0;
  198.         else
  199.             has_n_list = 1 + tup_size(tup);
  200.         fnum[fnums++] = has_n_list;
  201.     }
  202.     /* ast fields */
  203.     /* See comment above for description of compact format.*/
  204.     if (N_AST1_DEFINED(nk)) {
  205.         nod = N_AST1(node);
  206.         fnum[fnums++] = (N_UNIT(nod) != 0) ? N_SEQ(nod) : -1;
  207.     }
  208.     if (N_AST2_DEFINED(nk)) {
  209.         nod = N_AST2(node);
  210.         fnum[fnums++] = (N_UNIT(nod) != 0) ? N_SEQ(nod) : -1;
  211.     }
  212.     if (N_AST3_DEFINED(nk)) {
  213.         nod = N_AST3(node);
  214.         fnum[fnums++] = (N_UNIT(nod) != 0) ? N_SEQ(nod) : -1;
  215.     }
  216.     if (N_AST4_DEFINED(nk)) {
  217.         nod = N_AST4(node);
  218.         fnum[fnums++] = (N_UNIT(nod) != 0) ? N_SEQ(nod) : -1;
  219.     }
  220.     /*fnum[fnums++] = N_SIDE(node);*/
  221.     /* N_UNQ only if defined */
  222.     if (N_UNQ_DEFINED(nk))  {
  223.         sym = N_UNQ(node);
  224.         fnum[fnums++] = (sym != (Symbol)0) ? S_SEQ(sym) : 0;
  225.         fnum[fnums++] = (sym != (Symbol)0) ? S_UNIT(sym) : 0;
  226.     }
  227.     if (N_TYPE_DEFINED(nk)) {
  228.         sym = N_TYPE(node);
  229.         fnum[fnums++] = (sym != (Symbol)0) ? S_SEQ(sym) : 0;
  230.         fnum[fnums++] = (sym != (Symbol)0) ? S_UNIT(sym) : 0;
  231.     }
  232.     /* write fnums followed by fnum info as array */
  233.  
  234.     putnum(ofile, desc, fnums);
  235. #ifdef IOT
  236.     if (ofile->fh_trace == 2) libnodt(ofile, node, fnums, has_n_list);
  237. #endif
  238. #ifdef HI_LEVEL_IO
  239.     /*fwrite((char *) &fnums, sizeof(short), 1, ofile->fh_file);*/
  240.     fwrite((char *) fnum, sizeof(short), fnums, ofile->fh_file);
  241. #else
  242.     /*write(ofile->fh_file, (char *) &fnums, sizeof(short));*/
  243.     write(ofile->fh_file, (char *) fnum, fnums * sizeof(short));
  244. #endif
  245.  
  246.     /* write out n_list if needed */
  247.     if (has_n_list>1) {
  248.         tup = N_LIST(node);
  249.         FORTUP(nod = (Node), tup, ft1);
  250.             putnodref(ofile, "n-list-nodref", nod);
  251.         ENDFORTUP(ft1);
  252.     }
  253.     if (N_VAL_DEFINED(nk)) {
  254.         putnval(ofile, node);
  255.     }
  256. }
  257.  
  258. static void putnodref(IFILE *ofile, char *desc, Node node)        /*;putnodref*/
  259. {
  260.     /* OPT_NODE is node in unit 0 with sequence 1, and needs
  261.      * no special handling here
  262.      */
  263.  
  264. #ifdef IOT
  265.     if (ofile->fh_trace == 2) printf("%s ", desc);
  266. #endif
  267.     if (node == (Node)0) {
  268.         putpos(ofile, "nref-seq", 0);
  269.         putunt(ofile, "nref-unt", 0);
  270.     }
  271.     else {
  272.         putpos(ofile, "nref-seq", N_SEQ(node));
  273.         putunt(ofile, "nref-unt", N_UNIT(node));
  274.     }
  275. }
  276.  
  277. static void putint(IFILE *ofile, char *desc, int n)                /*;putint*/
  278. {
  279.     /* write int to output file */
  280.  
  281.     int s = n;
  282.  
  283. #ifdef IOT
  284.     if (ofile->fh_trace>1) {
  285.         iot_info(ofile, desc);
  286.         printf(" (int) %ld\n", n);
  287.     }
  288. #endif
  289.  
  290. #ifdef HI_LEVEL_IO
  291.     fwrite((char *) &s, sizeof(int), 1, ofile->fh_file);
  292. #else
  293.     write(ofile->fh_file, (char *) &s, sizeof(int));
  294. #endif
  295. }
  296.  
  297. static void putlong(IFILE *ofile, char *desc, long n)                /*;putlong*/
  298. {
  299.     /* write long to output file */
  300.  
  301.     long s = n;
  302. #ifdef IOT
  303.     if (ofile->fh_trace>1) {
  304.         iot_info(ofile, desc);
  305.         printf(" (long) %ld\n", n);
  306.     }
  307. #endif
  308.  
  309. #ifdef HI_LEVEL_IO
  310.     fwrite((char *) &s, sizeof(long), 1, ofile->fh_file);
  311. #else
  312.     write(ofile->fh_file, (char *) &s, sizeof(long));
  313. #endif
  314. }
  315.  
  316. static void putmisc(IFILE *ofile, Symbol sym)                /*;putmisc*/
  317. {
  318.     /* write out MISC information if present 
  319.      * MISC is integer except for package, in which case it is a triple.
  320.      * The first two components are integers, the last is  a tuple of
  321.      * symbols
  322.      */
  323.  
  324.     int    nat, i, n;
  325.     char   *m;
  326.     Tuple tup;
  327.  
  328.     nat = NATURE(sym);
  329.     m = MISC(sym);
  330.     if ((nat == na_package || nat == na_package_spec )&& m != (char *)0) {
  331.         tup = (Tuple) m;
  332.         putnum(ofile, "misc-package-1", (int)tup[1]);
  333.         putnum(ofile, "misc-package-2", (int)tup[2]);
  334.         tup = (Tuple) tup[3];
  335.         n = tup_size(tup);
  336.         putnum(ofile, "misc-package-tupsize", n);
  337.         for (i = 1; i <= n; i++)
  338.             putsymref(ofile, "misc-package-symref", (Symbol) tup[i]);
  339.     }
  340.     else if ((nat == na_procedure || nat == na_function) && m != (char *)0) {
  341.         /* misc is tuple. first entry is string, second is symbol */
  342.         tup = (Tuple) m;
  343.         putnum(ofile, "misc-number", (int) tup[1]);
  344.         putsymref(ofile, "misc-symref", (Symbol) tup[2]);
  345.     }
  346.     else {
  347.         putnum(ofile, "misc", (int)m);
  348.     }
  349. }
  350.  
  351. static void putrepr(IFILE *ofile, Symbol sym)                /*;putrepr*/
  352. {
  353.     /* write out representation  information if present */
  354.  
  355.     int    i, n;
  356.     Tuple repr_tup, tup4, align_mod_tup, align_tup;
  357.     int        repr_tag, swap_private;
  358.     Fortup    ft1;
  359.  
  360.     swap_private = FALSE;
  361.     if (is_type(sym) && !(is_generic_type(sym))) {
  362. #ifdef TBSL
  363.         if (TYPE_OF(sym) == symbol_private ||
  364.             TYPE_OF(sym) == symbol_limited_private) {
  365.              vis_decl = private_decls_get((Private_declarations)
  366.                                          private_decls(SCOPE_OF(sym)), sym);
  367.            /*
  368.             * Check to seem if vis_decl is defined before swapping it. It 
  369.             * might be undefined in the case of compilation errors.
  370.             */
  371.             if (vis_decl != (Symbol)0) {
  372.                 private_decls_swap(sym, vis_decl);
  373.                    swap_private = TRUE;
  374.             }
  375.         }
  376. #endif
  377.         repr_tup = REPR(sym);
  378.         if (repr_tup != (Tuple)0) repr_tag = (int) repr_tup[1];     
  379.         if (repr_tup == (Tuple)0) { /* probably error condition */
  380.            putnum(ofile, "repr-type", -1);
  381.         }
  382.         else if (repr_tag == TAG_RECORD) {
  383.             putnum(ofile, "repr-type", repr_tag);
  384.                putnum(ofile,"repr-rec-size %d\n", (int) repr_tup[2]);
  385.             align_mod_tup = (Tuple) repr_tup[4];
  386.                putnum(ofile,"repr-rec-mod %d\n", (int) align_mod_tup[1]);
  387.             align_tup = (Tuple) align_mod_tup[2];
  388.             putnum(ofile, "repr-align-tup-size", tup_size(align_tup));
  389.             FORTUP (tup4=(Tuple), align_tup, ft1);
  390.                 putsymref(ofile,"repr-rec-align-1", (Symbol)tup4[1]);
  391.                 putnum(ofile,"repr-rec-align-2", (int) tup4[2]);
  392.                 putnum(ofile,"repr-rec-align-3", (int) tup4[3]);
  393.                 putnum(ofile,"repr-rec-align-4", (int) tup4[4]);
  394.             ENDFORTUP(ft1);
  395.         }
  396.         else if (repr_tag == TAG_ACCESS || 
  397.                  repr_tag == TAG_TASK) {
  398.             putnum(ofile, "repr-type", repr_tag);
  399.             putnum(ofile, "repr-size", (int)repr_tup[2]);
  400.             putnodref(ofile, "repr-storage-size", (Node) repr_tup[3]);
  401.         }
  402.         else {
  403.             putnum(ofile, "repr-type", repr_tag);
  404.             putnum(ofile, "repr-tup-size", (int)repr_tup[0]);
  405.             n = tup_size(repr_tup);
  406.             for (i = 2; i <= n; i++)
  407.                 putnum(ofile, "repr-info", (int) repr_tup[i]);
  408.             }
  409.         }
  410.     else {
  411.         putnum(ofile, "repr-type", -1);
  412.     }
  413. #ifdef TBSL
  414.     if (swap_private)
  415.         private_decls_swap(sym, vis_decl);
  416. #endif
  417. }
  418. static void putunt(IFILE *ofile, char *desc, unsigned int n)        /*;putunt*/
  419. {
  420.     /* like putnum, but verifies that argument positive 
  421.      * and also that it is 'small'. In particular this is used
  422.      * to guard for absurd unit numbers 
  423.      */
  424.     /* write integer (as a short) to output file */
  425.  
  426.     if (n > 200) chaos("putunt: absurd unit number");
  427.     putnum(ofile, desc, (int) n);
  428. }
  429.  
  430. static void putnval(IFILE *ofile, Node node)                    /*;putnval*/
  431. {
  432.     /* write out N_VAL field for node to AISFILE */
  433.  
  434.     int nk, ck, nv;
  435.     Const    con;
  436.     char    *s;
  437.     char    *inttos();
  438.     Rational    rat;
  439.     Tuple    tup, stup;
  440.     int        i, n;
  441.     int        *ui;
  442.     double    doub;
  443.  
  444.     nk = N_KIND(node);
  445.     s = N_VAL(node);
  446.     if (nk == as_simple_name || nk == as_int_literal || nk == as_real_literal
  447.       || nk == as_string_literal || nk == as_character_literal 
  448.       || nk == as_subprogram_stub_tr || nk == as_package_stub
  449.       || nk == as_task_stub) {
  450.         putstr(ofile, "nval-name", s);
  451.     }
  452.     else if (nk == as_line_no || nk == as_number || nk == as_predef) {
  453.         putnum(ofile, "nval-int", (int) s);
  454.     }
  455.     else if (nk == as_mode)  {
  456.         /* convert mode, indeed, the inverse of change made in astread*/
  457.         nv = (int) N_VAL(node);
  458.         putnum(ofile, "val-mode", nv);
  459.     }
  460.     else if (nk == as_ivalue ) {
  461.         con = (Const) N_VAL(node);
  462.         ck = con->const_kind;
  463.         putnum(ofile, "nval-const_kind", ck);
  464.         if (ck == CONST_INT)
  465.             putint(ofile, "nval-const-int-value", con->const_value.const_int);
  466.         else if (ck == CONST_REAL) {
  467.             doub = con->const_value.const_real;
  468. #ifdef HI_LEVEL_IO
  469.             fwrite((char *) &doub, sizeof(double), 1, ofile->fh_file);
  470. #else
  471.             write(ofile->fh_file, (char *) &doub, sizeof(double));
  472. #endif
  473.         }
  474.         else if (ck == CONST_UINT) {
  475.             ui = con->const_value.const_uint;
  476.             putuint(ofile, "nval-const-uint", ui);
  477.         }
  478.         else if (ck == CONST_OM) {
  479.             ; /* no further data needed if OM */
  480.         }
  481.         else if (ck == CONST_RAT) {
  482.             rat = con->const_value.const_rat;
  483.             putuint(ofile, "nval-const-rat-num", rat->rnum);
  484.             putuint(ofile, "nval-const-rat-den", rat->rden);
  485.         }
  486.         else if (ck == CONST_CONSTRAINT_ERROR) {
  487.             chaos("putnval: CONST_CONSTRAINT_ERROR");
  488.         }
  489.     }
  490.     else if (nk == as_terminate_alt) {
  491.         /*: terminate_statement (9)  nval is depth_count (int)*/
  492.         putnum(ofile, "nval-terminate-depth", (int) s);
  493.     }
  494.     else if (nk == as_string_ivalue) {
  495.         /* nval is tuple of integers */
  496.         tup = (Tuple) s;
  497.         n = tup_size(tup);
  498.         putnum(ofile, "nval-string-ivalue-size", n);
  499.         for (i = 1; i <= n; i++) {
  500.             putchr(ofile, "nval-string-ivalue", (int) tup[i]);
  501.         }
  502.     }
  503.     else if (nk == as_instance_tuple) {
  504.         stup = (Tuple) s;
  505.         if (stup != (Tuple)0) {
  506.             n = tup_size(stup);
  507.             if (n != 2)
  508.                 chaos("putnval: bad nval for instantiation");
  509.             putnum(ofile, "nval-instance-tupsize", n);
  510.             /* first component is instance map */
  511.             tup = ((Symbolmap)(stup)[1])->symbolmap_tuple;
  512.             n = tup_size(tup);
  513.             putnum(ofile, "nval-symbolmap-size", n);
  514.             for (i = 1; i <= n; i += 2) {
  515.                 putsymref(ofile, "symbolmap-1", (Symbol)tup[i]);
  516.                 putsymref(ofile, "symbolmap-2", (Symbol)tup[i+1]);
  517.             }
  518.             /* second component is needs_body flag */
  519.             putnum(ofile, "nval-flag", (int)(stup)[2]);
  520.         }
  521.         else putnum(ofile, "nval-instance-empty", 0);
  522.     }
  523.     /* need to handle following cases:
  524.      * (when do them, update libr and libs as well).
  525.      *     see also how handled for record_aggregates (gs: as_simple_name nodes
  526.      *             now attatched to n_list of as_record_aggregate )
  527.      * as_pragma: cf. process_pragma (2)
  528.      * as_array aggregate
  529.      * Need to review assignments of N_VAL in chapter 12, including:
  530.      *     as_generic: (cf. 12)
  531.      *     see subprog_instance (12) where N_VAL set to triple.
  532.      */
  533. }
  534.  
  535. static void putuint(IFILE *ofile, char *desc, int *pint)            /*;putuint*/
  536. {
  537.     int n;
  538. #ifdef IOT
  539.     int    i;
  540.  
  541.     n = pint[0];
  542.     putnum(ofile, "uint_size", n);
  543. #ifdef HI_LEVEL_IO
  544.     fwrite((char *) pint, sizeof(int), n+1, ofile->fh_file);
  545. #else
  546.     write(ofile->fh_file, (char *) pint, sizeof(int)*(n+1));
  547. #endif
  548.     if (ofile->fh_trace<2) return;
  549.     for (i = 1; i <= n; i++)
  550.         printf("uint-word %d %d\n", i, pint[i]);
  551. #else
  552.     n = pint[0];
  553.     putnum(ofile, "uint-size", n);
  554. #ifdef HI_LEVEL_IO
  555.     fwrite((char *) pint, sizeof(int), n+1, ofile->fh_file);
  556. #else
  557.     write(ofile->fh_file, (char *) pint, sizeof(int)*(n+1));
  558. #endif
  559. #endif
  560. }
  561.  
  562. static void putovl(IFILE *ofile, Symbol sym)                    /*;putovl*/
  563. {
  564.     int nat, n;
  565.     Set ovl;
  566.     Forset    fs1;
  567.     Forprivate_decls    fp;
  568.     Private_declarations    pd;
  569.     Symbol    s, s1, s2;
  570.  
  571.     nat = NATURE(sym);
  572.     ovl = OVERLOADS(sym);
  573.  
  574.     /* It is the private declarations for na_package and na_package_spec.
  575.      * (and also na_generic_package_spec)
  576.      * Otherwise it is a set of symbols:
  577.      *    na_aggregate  na_entry    na_function  na_function_spec
  578.      *    na_literal  na_op  na_procedure     na_procedure_spec
  579.      */
  580.     if (nat == na_block) {
  581.         /* ignore any overloads info for block - it is for internal use only */
  582.         return;
  583.     }
  584.     if (nat == na_package|| nat == na_package_spec
  585.       || nat == na_generic_package_spec || nat == na_generic_package
  586.       || nat == na_task_type || nat == na_task_obj) {
  587.         /* write out private declarations */
  588.         pd = (Private_declarations) ovl;
  589.         n = 0;
  590.         FORPRIVATE_DECLS(s1, s2, pd, fp);
  591.             n += 1;
  592.         ENDFORPRIVATE_DECLS(fp);
  593.         putnum(ofile, "ovl-private-decls-size", n);
  594.         FORPRIVATE_DECLS(s1, s2, pd, fp);
  595.             putsym(ofile, "ovl-pdecl-1-sym", s1);
  596.             putsym(ofile, "ovl-pdecl-2-sym", s2);
  597.         ENDFORPRIVATE_DECLS(fp);
  598.     }
  599.     else if (ovl != (Set)0) {
  600.         putnum(ofile, "ovl-set-size", set_size(ovl));
  601.         FORSET(s = (Symbol), ovl, fs1);
  602.             putsymref(ofile, "ovl-set-symref", s);
  603.         ENDFORSET(fs1);
  604.     }
  605.     else {
  606.         chaos("putovl surprising case!");
  607.     }
  608. }
  609.  
  610. static void putsig(IFILE *ofile, Symbol sym)                /*;putsig*/
  611. {
  612.     /* The signature field is used as follows:
  613.      * It is a symbol for:
  614.      *    na_access
  615.      * It is a node for
  616.      *    na_constant  na_in  na_inout
  617.      * It is also a node (always OPT_NODE) for na_out. For now we write this
  618.      * out even though it is not used. 
  619.      * It is a pair for na_array.
  620.      * It is a triple for na_enum.
  621.      * It is a triple for na_generic_function_spec na_generic_procedure_spec
  622.      * The first component is a tuple of pairs, each pair consisting of
  623.      * a symbol and a (default) node.
  624.      * The second component is a tuple of symbols.
  625.      * The third component is a node
  626.      * It is a tuple with four elements for na_generic_package_spec:
  627.      * the first is a tuple of pairs, with same for as for generic procedure.
  628.      * the second third, and fourth components are nodes.
  629.      * It is a 5-tuple for na_record.
  630.      * It is a constraint for na_subtype and na_type.
  631.      * It is a node for na_obj.
  632.      * Otherwise it is the signature for a procedure, namely a tuple
  633.      * of quadruples.
  634.      * Note however, that for a private type, the signature has the same
  635.      * form as for a record.
  636.      * For a subtype whose root type is an array, the signature has the
  637.      * same form as for an array.
  638.      * For task_type, task_type_spec, it is a tuple of nodes 
  639.      *  (created by the expander)
  640.      * For task_body it is a tuple (empty) to make it correspond to procedures.
  641.      *  (modified in expanded for as_task)
  642.      */
  643.  
  644.     int nat, i, n;
  645.     Tuple    sig, tup, tupent;
  646.     Symbol    s, s2;
  647.     Fortup    ft1;
  648.  
  649.     nat = NATURE(sym);
  650.     sig = SIGNATURE(sym);
  651.     switch (nat) {
  652.     case na_access:
  653.         /* access: signature is designated_type;*/
  654.         putsymref(ofile, "sig-access-symref", (Symbol) sig);
  655.         break;
  656.     case    na_array:
  657.         /* array: signature is pair [i_types, comp_type] where
  658.          * i_type is tuple of type names
  659.          */
  660. array_case:
  661.         putnum(ofile, "sig-array-i-types-size", tup_size((Tuple) sig[1]));
  662.         FORTUP(s = (Symbol), (Tuple) sig[1], ft1);
  663.             putsymref(ofile, "sig-array-i-types-type", s);
  664.         ENDFORTUP(ft1);
  665.         putsymref(ofile, "sig-array-comp-type", (Symbol) sig[2]);
  666.         break;
  667.     case    na_block:
  668.         /* block: miscellaneous information */
  669.         /* This information not needed externally*/
  670.         chaos("putsig: signature for block");
  671.         break;
  672.     case    na_constant:
  673.     case    na_in:
  674.     case    na_inout:
  675.     case    na_out:
  676.     case    na_discriminant:
  677.         putnodref(ofile, "sig-discriminant-nodref", (Node) sig);
  678.         break;
  679.     case    na_entry:
  680.     case    na_entry_family:
  681.     case    na_entry_former:
  682.         /* entry: list of symbols */
  683.     case    na_function:
  684.     case    na_function_spec:
  685.     case    na_literal:        /* is this for literals too? */
  686.     case    na_op:
  687.     case    na_procedure:
  688.     case    na_procedure_spec:
  689.     case    na_task_body:
  690.         putnum(ofile, "sig-tuple-size", tup_size(sig));
  691.         FORTUP(s = (Symbol), sig, ft1);
  692.             putsymref(ofile, "sig-tuple-symref", s);
  693.         ENDFORTUP(ft1);
  694.         break;
  695.     case    na_enum:
  696.         /* enum: tuple in form ['range', lo, hi]*/
  697.         /* we write this as two node references*/
  698.         putnodref(ofile, "sig-enum-low-nodref", (Node) sig[2]);
  699.         putnodref(ofile, "sig-enum-high-nodref", (Node) sig[3]);
  700.         break;
  701.     case    na_type:
  702.         /* treat private types way in same way as for records*/
  703.         s = TYPE_OF(sym);
  704.         s2 = TYPE_OF(root_type(sym));
  705.         if ( s == symbol_private || s == symbol_limited_private 
  706.           || s== symbol_incomplete || s2 == symbol_private 
  707.           || s2 == symbol_limited_private || s2 == symbol_incomplete
  708.           || (s != (Symbol)0 && NATURE(s) == na_record)
  709.             /* derived of private record or record */
  710.           || (s2 != (Symbol)0 && NATURE(s2) == na_record)) {
  711.             /* derived of derived of ... */
  712.             goto record_case;
  713.         }
  714.         if ((s != (Symbol)0 && NATURE(s) == na_access)
  715.           || (s2 != (Symbol)0 && NATURE(s2) == na_access)) {
  716.             putsymref(ofile, "sig-access-symref", (Symbol) sig);
  717.             break;
  718.         }
  719.         n = tup_size(sig);
  720.         putnum(ofile, "sig-type-size", n);
  721.         putnum(ofile, "sig-type-constraint-kind", (int) sig[1]);
  722.         for (i = 2; i <= n; i++)
  723.             putnodref(ofile, "sig-type-nodref", (Node) sig[i]);
  724.         break;
  725.     case na_subtype:
  726.         n = tup_size(sig);
  727.         putnum(ofile, "sig-subtype-size", n);
  728.         if (is_array(sym)) { /* if constrained array */
  729.             putnum(ofile, "sig-constrained-array", CONSTRAINT_ARRAY);
  730.             goto array_case;
  731.         }
  732.         putnum(ofile, "sig-type-constraint-kind", (int) sig[1]);
  733.         if ((int)sig[1] == CONSTRAINT_DISCR) {
  734.             /* discriminant map */
  735.             tup = (Tuple) numeric_constraint_discr(sig);
  736.             n = tup_size(tup);
  737.             putnum(ofile, "sig-constraint-discrmap-size", n);
  738.             for (i = 1; i <= n; i += 2) {
  739.                 putsymref(ofile, "sig-constraint-discrmap-symref",
  740.                   (Symbol)tup[i]);
  741.                 putnodref(ofile, "sig-constraint-discrmap-nodref",
  742.                   (Node) tup[i+1]);
  743.             }
  744.         }
  745.         else if ((int)sig[1] == CONSTRAINT_ACCESS) {
  746.             putsymref(ofile, "sig-subtype-acc-symref", (Symbol)sig[2]);
  747.         }
  748.         else {
  749.             for (i = 2; i <= n; i++)
  750.                 putnodref(ofile, "sig-subtype-nodref", (Node) sig[i]);
  751.         }
  752.         break;
  753.     case    na_generic_function:
  754.     case    na_generic_procedure:
  755.     case    na_generic_function_spec:
  756.     case    na_generic_procedure_spec:
  757.         if (tup_size(sig) != 4)
  758.             chaos("putsig: bad signature for na_generic_procedure_spec");
  759.         /* tuple count known to be four, just put elements */
  760.         tup = (Tuple) sig[1];
  761.         /* the first component is a tuple of pairs, just write count
  762.          * and the values of the successive pairs 
  763.          */
  764.         n = tup_size(tup);
  765.         putnum(ofile, "sig-generic-size", n);
  766.         for (i = 1; i <= n; i++) {
  767.             tupent = (Tuple) tup[i];
  768.             putsymref(ofile, "sig-generic-symref", (Symbol) tupent[1]);
  769.             putnodref(ofile, "sig-generic-nodref", (Node) tupent[2]);
  770.         }
  771.         tup = (Tuple) sig[2];
  772.         n = tup_size(tup); /* symbol list */
  773.         putnum(ofile, "sig-generic-tup-size", n);
  774.         for (i = 1; i <= n; i++)
  775.             putsymref(ofile, "sig-generic-symbol-symref", (Symbol) tup[i]);
  776.         putnodref(ofile, "sig-generic-3-nodref", (Node) sig[3]);
  777.         /* the fourth component is tuple of symbols */
  778.         tup = (Tuple) sig[4];
  779.         n = tup_size(tup);
  780.         putnum(ofile, "sig-generic-contrain-size", n);
  781.         for (i = 1; i <= n; i++)
  782.             putsymref(ofile, "sig-generic-symref", (Symbol)tup[i]);
  783.         break;
  784.     case    na_generic_package_spec:
  785.     case    na_generic_package:
  786.         /* signature is tuple with five elements */
  787.         if (tup_size(sig) != 5)
  788.             chaos("putsig: bad signature for na_generic_package_spec");
  789.         tup = (Tuple) sig[1];
  790.         /* the first component is a tuple of pairs, just write count
  791.          * and the values of the successive pairs 
  792.          */
  793.         n = tup_size(tup);
  794.         putnum(ofile, "sig-generic-tup-size", n);
  795.         for (i = 1; i <= n; i++) {
  796.             tupent = (Tuple) tup[i];
  797.             putsymref(ofile, "sig-generic-symref", (Symbol) tupent[1]);
  798.             putnodref(ofile, "sig-generic-nodref", (Node) tupent[2]);
  799.         }
  800.         /* the second third, and fourth components are just nodes */
  801.         putnodref(ofile, "sig-generic-node-2", (Node) sig[2]);
  802.         putnodref(ofile, "sig-generic-node-3", (Node) sig[3]);
  803.         putnodref(ofile, "sig-generic-node-4", (Node) sig[4]);
  804.         /* the fifth component is tuple of symbols */
  805.         tup = (Tuple) sig[5];
  806.         n = tup_size(tup);
  807.         putnum(ofile, "sig-generic-contrain-size", n);
  808.         for (i = 1; i <= n; i++)
  809.             putsymref(ofile, "sig-generic-symref", (Symbol)tup[i]);
  810.         break;
  811.     case    na_record:
  812.         /* the signature is tuple with five components:
  813.          * [node, node, tuple of symbols, declaredmap, node]
  814.          * NOTE: we do not write component count - 5 assumed 
  815.          */
  816. record_case:
  817.         putnodref(ofile, "sig-record-1-nodref", (Node) sig[1]);
  818.         putnodref(ofile, "sig-record-2-nodref", (Node) sig[2]);
  819.         tup = (Tuple) sig[3];
  820.         n = tup_size(tup);
  821.         putnum(ofile, "sig-record-3-size", n);
  822.         for (i = 1; i <= n; i++)
  823.             putsymref(ofile, "sig-record-3-symref", (Symbol) tup[i]);
  824.         putdcl(ofile, (Declaredmap) sig[4]);
  825.         putnodref(ofile, "sig-record-5-nodref", (Node) sig[5]);
  826.         break;
  827.     case    na_void:
  828.         /* special case assume entry for $used, in which case is tuple
  829.          * of symbols
  830.          */
  831.         if (streq(ORIG_NAME(sym), "$used") ) {
  832.             n = tup_size(sig);
  833.             putnum(ofile, "sig-$used-size", n);
  834.             for (i = 1; i <= n; i++)
  835.                 putsymref(ofile, "sig-$used-symref", (Symbol) sig[i]);
  836.         }
  837.         else {
  838. #ifdef DEBUG
  839.             zpsym(sym);
  840. #endif
  841.             chaos("putsig: na_void, not $used");
  842.         }
  843.         break;
  844.     case    na_obj:
  845.         putnodref(ofile, "sig-obj-nodref", (Node) sig);
  846.         break;
  847.     case na_task_type:
  848.     case na_task_type_spec:
  849.         /* a tuple of nodes */
  850.         n = tup_size(sig);
  851.         putnum(ofile, "task-type-spec-size", n);
  852.         for (i = 1; i <= n; i++)
  853.             putnodref(ofile, "sig-task-nodref", (Node)sig[i]);
  854.         break;
  855.     default:
  856. #ifdef DEBUG
  857.         printf("putsig: default error\n");
  858.         zpsym(sym);
  859. #endif
  860.         chaos("putsig: default");
  861.     }
  862. }
  863.  
  864. static void putsym(IFILE *ofile, char *desc, Symbol sym)            /*;putsym*/
  865. {
  866.     /* write description for symbol sym to output file */
  867.  
  868.     struct f_symbol_s fs;
  869.     int nat;
  870.     Tuple    sig, tup;
  871.     Set     set;
  872.     Symbol    s, s2;
  873.     Fortup    ft1;
  874.  
  875. #ifdef IOT
  876.     if (iot_ais_w == 1) printf("putsymbol %d %d\n", S_SEQ(sym), S_UNIT(sym));
  877.     if (ofile->fh_trace == 2) iot_info(ofile, desc);
  878. #endif
  879.     nat = NATURE(sym);
  880. #ifdef DEBUG
  881.     if (trapss>0 && S_SEQ(sym) == trapss && S_UNIT(sym) == trapsu) traps(sym);
  882. #endif
  883.     fs.f_symbol_nature = nat;
  884.     fs.f_symbol_seq = S_SEQ(sym);
  885.     fs.f_symbol_unit = S_UNIT(sym);
  886.     s = TYPE_OF(sym);
  887.     if (s == (Symbol)0) {
  888.         fs.f_symbol_type_of_seq = 0;
  889.         fs.f_symbol_type_of_unit = 0;
  890.     }
  891.     else {
  892.         fs.f_symbol_type_of_seq = S_SEQ(s);
  893.         fs.f_symbol_type_of_unit = S_UNIT(s);
  894.     }
  895.     sig = SIGNATURE(sym);
  896.     if (sig == (Tuple)0) {
  897.         fs.f_symbol_signature = 0;
  898.     }
  899.     else {
  900.         /* signature field not relevant for na_block externally */
  901.         fs.f_symbol_signature = 1;
  902.         if (nat == na_block) fs.f_symbol_signature = 0;
  903.     }
  904.     s = SCOPE_OF(sym);
  905.     if (s == (Symbol)0) {
  906.         fs.f_symbol_scope_of_seq = 0;
  907.         fs.f_symbol_scope_of_unit = 0;
  908.     }
  909.     else {
  910.         fs.f_symbol_scope_of_seq = S_SEQ(s);
  911.         fs.f_symbol_scope_of_unit = S_UNIT(s);
  912.     }
  913.     s = ALIAS(sym);
  914.     if (s == (Symbol)0) {
  915.         fs.f_symbol_alias_seq = 0;
  916.         fs.f_symbol_alias_unit = 0;
  917.     }
  918.     else {
  919.         fs.f_symbol_alias_seq = S_SEQ(s);
  920.         fs.f_symbol_alias_unit = S_UNIT(s);
  921.     }
  922.     set = OVERLOADS(sym);
  923.     if (set == (Set)0) {
  924.         fs.f_symbol_overloads = 0;
  925.     }
  926.     else {
  927.         fs.f_symbol_overloads = 1;
  928.         if (nat == na_block) fs.f_symbol_overloads = 0;
  929.     }
  930.     if (DECLARED(sym) != (Declaredmap)0) {
  931.         fs.f_symbol_declared = 1;
  932.     }
  933.     else {
  934.         fs.f_symbol_declared = 0;
  935.     }
  936.     fs.f_symbol_type_attr = TYPE_ATTR(sym);
  937.     s = TYPE_OF(sym);
  938.     if (NATURE(sym) == na_type ) {
  939.         s2 = TYPE_OF(root_type(sym));
  940.         if (s == symbol_private || s == symbol_limited_private 
  941.           || s == symbol_incomplete || s2 == symbol_private 
  942.           || s2 == symbol_limited_private || s2 == symbol_incomplete
  943.           /* I think the following test is true in case of derived of record 
  944.            * and therefore that the code is wrong. JC
  945.            */
  946.           || (s != (Symbol)0 && NATURE(s) == na_record)
  947.           /* derived of private record or record */
  948.           || (s2 != (Symbol)0 && NATURE(s2) == na_record)) {
  949.             /* derived of derived of ... */
  950.             fs.f_symbol_type_attr |= TA_ISPRIVATE;
  951.         }
  952.     }
  953.     /* The following fields are for use by the code generator only */
  954.     fs.f_symbol_misc = (MISC(sym) != (char *)0);
  955.     fs.f_symbol_type_kind = TYPE_KIND(sym);
  956.     fs.f_symbol_type_size = TYPE_SIZE(sym);
  957.     s = INIT_PROC(sym);
  958.     if (s == (Symbol)0) {
  959.         fs.f_symbol_init_proc_seq = 0;
  960.         fs.f_symbol_init_proc_unit = 0;
  961.     }
  962.     else if (!is_type(sym)) {
  963.         /* case of formal_decl_tree for subprogram specs */
  964.         fs.f_symbol_init_proc_seq = N_SEQ((Node)s);
  965.         fs.f_symbol_init_proc_unit = N_UNIT((Node)s);
  966.     }
  967.     else {
  968.         fs.f_symbol_init_proc_seq = S_SEQ(s);
  969.         fs.f_symbol_init_proc_unit = S_UNIT(s);
  970.     }
  971.     tup = ASSOCIATED_SYMBOLS(sym);
  972.     if (tup == (Tuple)0) {
  973.         fs.f_symbol_assoc_list = 0;
  974.     }
  975.     else {
  976.         if (nat == na_in || nat == na_out || nat == na_inout) {
  977.             /* avoid writing associated symbols for functions and subprograms
  978.              * as these need not be written  ds 9-aug-85
  979.              */
  980.             fs.f_symbol_assoc_list = 0;
  981.         }
  982.         else {
  983.             fs.f_symbol_assoc_list = 1 + tup_size(tup);
  984.         }
  985.     }
  986.     fs.f_symbol_s_segment = S_SEGMENT(sym);
  987.     fs.f_symbol_s_offset = S_OFFSET(sym);
  988. #ifdef IOT
  989.     if (ofile->fh_trace == 2) {
  990.         printf("%d %s = s(%d,%d) type_of(%d,%d)\n",
  991.           fs.f_symbol_nature, nature_str(fs.f_symbol_nature), fs.f_symbol_seq,
  992.           fs.f_symbol_unit, fs.f_symbol_type_of_seq, fs.f_symbol_type_of_unit);
  993.         printf(
  994.           "scope_of(%d,%d) sig %d ovl %d dcl %d alias(%d,%d) attr %d misc %d\n",
  995.           fs.f_symbol_scope_of_seq, fs.f_symbol_scope_of_unit,
  996.           fs.f_symbol_signature, fs.f_symbol_overloads,
  997.           fs.f_symbol_declared, fs.f_symbol_alias_seq, fs.f_symbol_alias_unit,
  998.           fs.f_symbol_type_attr,
  999.           fs.f_symbol_misc);
  1000.         printf("t_kind %d t_size %d init_proc(%d,%d) assoc %d seg %d off %d\n",
  1001.           fs.f_symbol_type_kind, fs.f_symbol_type_size,
  1002.           fs.f_symbol_init_proc_seq, fs.f_symbol_init_proc_unit,
  1003.           fs.f_symbol_assoc_list,  fs.f_symbol_s_segment, fs.f_symbol_s_offset);
  1004.     }
  1005. #endif
  1006.  
  1007. #ifdef HI_LEVEL_IO
  1008.     fwrite((char *) &fs, sizeof(f_symbol_s), 1, ofile->fh_file);
  1009. #else
  1010.     write(ofile->fh_file, (char *) &fs, sizeof(f_symbol_s));
  1011. #endif
  1012.     putstr(ofile, "orig-name", ORIG_NAME(sym));
  1013.     /* process overloads separately due to variety of cases */
  1014.     /* treat na_enum case separately */
  1015.     if (fs.f_symbol_overloads) {
  1016.         if(fs.f_symbol_nature == na_enum)
  1017.             putlitmap(ofile, sym);
  1018.         else
  1019.             putovl(ofile, sym);
  1020.     }
  1021.     if (fs.f_symbol_declared)
  1022.         putdcl(ofile, DECLARED(sym));
  1023.     /* signature */
  1024.     if (fs.f_symbol_signature)
  1025.         putsig(ofile, sym);
  1026.  
  1027.     putmisc(ofile, sym);
  1028.  
  1029.     /* write out associated symbols of necessary */
  1030.     if (fs.f_symbol_assoc_list > 1) {
  1031.         tup = ASSOCIATED_SYMBOLS(sym);
  1032.         FORTUP(s = (Symbol), tup, ft1)
  1033.             putsymref(ofile, "assoc-symbol-symref", s);
  1034.         ENDFORTUP(ft1);
  1035.     }
  1036.     putrepr(ofile, sym);
  1037. }
  1038.  
  1039. void putsymref(IFILE *ofile, char *desc, Symbol sym)        /*;putsymref*/
  1040. {
  1041. #ifdef IOT
  1042.     if (ofile->fh_trace == 2) printf("%s ", desc);
  1043. #endif
  1044.     if (sym == (Symbol)0) {
  1045.         putpos(ofile, "symref-seq", 0);
  1046.         putpos(ofile, "symref-unt", 0);
  1047.     }
  1048.     else {
  1049. #ifdef DEBUG
  1050.         if(trapss>0 && trapss == S_SEQ(sym) && trapsu == S_UNIT(sym))traps(sym);
  1051. #endif
  1052.         putpos(ofile, "symref-seq", S_SEQ(sym));
  1053.         putpos(ofile, "symref-unt", S_UNIT(sym));
  1054.     }
  1055. }
  1056.  
  1057. static void putudecl(IFILE *ofile, int ui)                        /*;putudecl*/
  1058. {
  1059.     int i, n, cn, ci;
  1060.     Tuple    tup, cent, ctup, cntup;
  1061.     Unitdecl    ud;
  1062.  
  1063.     ud = (Unitdecl) pUnits[ui]->aisInfo.unitDecl;
  1064.     putsym(ofile, "ud-unam", ud->ud_unam);
  1065.     put_unit_unam(ofile, ud->ud_unam);
  1066. #ifdef IOT
  1067.     if (iot_ais_w) printf("putudecl %d %s\n", ui, pUnits[ui]->name);
  1068.     if (iot_ais_w) printf("decl sequence %d\n", ud->ud_useq);
  1069. #endif
  1070.     /* context */
  1071.     ctup = (Tuple) ud->ud_context;
  1072.     if (ctup == (Tuple)0)
  1073.         n = 0;
  1074.     else
  1075.         n = tup_size(ctup)+1;
  1076. #ifdef IOT
  1077.     if (iot_ais_w) printf("decl context size %d\n", n);
  1078. #endif
  1079.     putnum(ofile, "decl-context-size", n);
  1080.     if (n > 1) {
  1081.         n -= 1;
  1082.         for (i = 1; i <= n; i++) {
  1083.             cent = (Tuple) ctup[i];
  1084. #ifdef IOT
  1085.             if (iot_ais_w)printf("context %d %d\n", i, cent[1]);
  1086. #endif
  1087.             putnum(ofile, "decl-ctup-1", (int) cent[1]);
  1088.             cntup = (Tuple) cent[2]; /* 2nd component is tuple of strings */
  1089.             cn = tup_size(cntup);
  1090.             putnum(ofile, "decl-cntup-size", cn);
  1091.             for (ci = 1; ci <= cn; ci++)
  1092.                 putstr(ofile, "decl-tupstr-str", cntup[ci]);
  1093.         }
  1094.     }
  1095.     /* unit_nodes */
  1096.     tup = ud->ud_nodes;
  1097.     n = tup_size(tup);
  1098.     putnum(ofile, "decl-ud-nodes-size", n);
  1099. #ifdef IOT
  1100.     if (iot_ais_w) printf("unit_nodes %d\n", n);
  1101. #endif
  1102.     for (i = 1; i <= n; i++) {
  1103.         putnodref(ofile, "decl-nodref", (Node) tup[i]);
  1104. #ifdef IOT
  1105.         if (iot_ais_w)
  1106.             printf("    node %d %d\n",N_SEQ((Node)tup[i]),N_UNIT((Node)tup[i]));
  1107. #endif
  1108.     }
  1109.     /* tuple of symbol table pointers */
  1110.     tup = ud->ud_symbols;
  1111.     if (tup == (Tuple)0)
  1112.         n = 0;
  1113.     else
  1114.         n = tup_size(tup)+1;
  1115.     putnum(ofile, "decl-symbol-tuple-size", n);
  1116. #ifdef IOT
  1117.     if (iot_ais_w) printf(" symbols %d\n", n);
  1118. #endif
  1119.     if (n>1) {
  1120.         n -= 1;
  1121.         for (i = 1; i <= n; i++) {
  1122.             /*putsymref(ofile, tup[i]);*/
  1123.             /* write full symbol def */
  1124.             putsym(ofile, "decl-symref", (Symbol) tup[i]);
  1125. #ifdef IOT
  1126.             if (iot_ais_w)
  1127.                 printf(" symbol %d %d\n",
  1128.                   S_SEQ((Symbol)tup[i]), S_UNIT((Symbol)tup[i]));
  1129. #endif
  1130.         }
  1131.     }
  1132.  
  1133. #ifdef IOT
  1134.     if (iot_ais_w) printf(" decscopes %d\n", n);
  1135. #endif
  1136.     /* decscopes - tuple of scopes */
  1137.     tup = ud->ud_decscopes;
  1138.     if (tup == (Tuple)0)
  1139.         n = 0;
  1140.     else
  1141.         n = tup_size(tup)+1;
  1142.     putnum(ofile, "decl-descopes-size", n);
  1143.     if (n > 1) {
  1144.         n -= 1;
  1145.         for (i = 1; i <= n; i++) {
  1146. #ifdef IOT
  1147.             if (iot_ais_w)
  1148.                 printf(" %d %d %d\n", i,
  1149.                   S_SEQ((Symbol)tup[i]), S_UNIT((Symbol)tup[i]));
  1150. #endif
  1151.             putsym(ofile, "decl-descopes-symref", (Symbol) tup[i]);
  1152.         }
  1153.     }
  1154.     /* decmaps - tuple of declared maps */
  1155.     tup = ud->ud_decmaps;
  1156.     if (tup == (Tuple)0)
  1157.         n = 0;
  1158.     else
  1159.         n = tup_size(tup)+1;
  1160.     putnum(ofile, "decmaps-tuple-size", n);
  1161. #ifdef IOT
  1162.     if (iot_ais_w) printf(" decmaps %d\n", n);
  1163. #endif
  1164.     if (n>1) {
  1165.         n -= 1;
  1166.         for (i = 1; i <= n; i++)
  1167.             putdcl(ofile, (Declaredmap) tup[i]);
  1168.     }
  1169.     /* oldvis - tuple of unit names */
  1170.     tup = ud->ud_oldvis;
  1171.     if (tup == (Tuple)0)
  1172.         n = 0;
  1173.     else
  1174.         n = tup_size(tup)+1;
  1175.     putnum(ofile, "vis", n);
  1176. #ifdef IOT
  1177.     if (iot_ais_w) printf(" oldvis %d\n", n);
  1178. #endif
  1179.     if (n>1) {
  1180.         n -= 1;
  1181.         for (i = 1; i <= n; i++) {
  1182.             putstr(ofile, "vis-str", tup[i]);
  1183. #ifdef IOT
  1184.             if (iot_ais_w == 1) printf("    %s\n", tup[i]);
  1185. #endif
  1186.         }
  1187.     }
  1188.     return;
  1189. }
  1190.  
  1191. long write_ais(int ui)                                        /*;write_ais*/
  1192. {
  1193.     /* Writes information from the current compilation to
  1194.      * 'file', restructuring the separate compilation maps
  1195.      * to improve the readability of the AIS code.
  1196.      */
  1197.  
  1198.     int     i, n, symbols, is_main;
  1199.     long    begpos, genoff, endpos;
  1200.     Tuple    tup;
  1201.     Set        set;
  1202.     Forset    fs1;
  1203.     IFILE    *ofile;
  1204.     struct unit *pUnit = pUnits[ui];
  1205.  
  1206.     ofile = AISFILE;
  1207.     begpos = write_next(ofile); /* start record*/
  1208.     putstr(ofile, "unit-name", pUnit->name); /* unit name */
  1209.     putnum(ofile, "unit-number", ui); /* unit number */
  1210.     genoff = iftell(ofile);
  1211.     /* offset to code generator information */
  1212.     putlong(ofile, "code-gen-offset", 0L);
  1213.     is_main = streq(unit_name_type(pUnit->name), "ma");
  1214.     if (!is_main) {
  1215. #ifdef IOT
  1216.         if (iot_ais_w) printf(" writing out ais symbol entries\n");
  1217. #endif
  1218.         putnum(ofile, "seq-symbol-n", seq_symbol_n);
  1219.         /* write out the number of tree node for this unit */
  1220.         putnum(ofile, "seq-node-n", seq_node_n);
  1221.         symbols = seq_symbol_n;
  1222.         pUnit->aisInfo.numberSymbols = symbols;
  1223.  
  1224.         /* ELABORATE PRAGMA INFO */
  1225.         tup = (Tuple) pUnit->aisInfo.pragmaElab;
  1226.         n = tup_size(tup);
  1227.         putnum(ofile, "pragma-info-size", n);
  1228.         for (i = 1; i <= n; i++)
  1229.             putstr(ofile, "pragma-str", tup[i]);        /* pragma info*/
  1230.         /* UNIT_DECL */
  1231.         putudecl(ofile, ui);
  1232.         /* now write out info for each symbol in compilation unit.
  1233.          * perhaps we need write out only those referenced in prior
  1234.          * items read in, but for now we write out all for sake of
  1235.          * completeness and to assist debugging     (ds 19-oct-84)
  1236.          */
  1237.         /* PRE_COMP */
  1238.         set = (Set) pUnit->aisInfo.preComp; /* pre_comp info*/
  1239.         n = set_size(set);
  1240.         putnum(ofile, "precomp-size", n);
  1241.         FORSET(n = (int), set, fs1);
  1242.             putnum(ofile, "precomp-value", n);
  1243.         ENDFORSET(fs1);
  1244.         ifseek(ofile, "seek-to-end", 0l, 2); /* position back at end*/
  1245.         tup = tup_new(symbols);
  1246.         for (i = 1; i <= symbols; i++)
  1247.             tup[i] = (char *) seq_symbol[i];
  1248.         pUnit->aisInfo.symbols = (char *) tup;
  1249.     }
  1250.     endpos = iftell(ofile); /* get current offset (end of sem info) */
  1251.     /* position to word to get end offset */
  1252.     ifseek(ofile, "seek-to-gen-offset", genoff, 0);
  1253.     putlong(ofile, "end-pos", endpos);
  1254.     ifseek(ofile, "seek-to-end", 0L, 2); /* move back to end of file */
  1255.     write_end(ofile, begpos);
  1256.     return begpos;
  1257. }
  1258.  
  1259. void write_stub(Stubenv ev, char *stub_name, char *ext)            /*;write_stub*/
  1260. {
  1261.     /* Writes information from the stub environment for stub si to the end of
  1262.      * STUBFILE. 
  1263.      * First open STUBFILE if this is first stub and therefore STUBFILE is not 
  1264.      * opened yet. The file extension ext is st1 for semantics phase and st2 for
  1265.      * the code generator phase.
  1266.      */
  1267.  
  1268.     int        i, j, k, n, m;
  1269.     long    begpos;
  1270.     Tuple    tup, tup2, tup3;
  1271.     int        cn, ci;
  1272.     Tuple    cent, cntup;
  1273.     IFILE    *ofile;
  1274.  
  1275.     if (STUBFILE == (IFILE *)0)
  1276.         STUBFILE = ifopen(AISFILENAME, ext, "w", "s", iot_ais_w, 0);
  1277.     ofile = STUBFILE;
  1278.     begpos = write_next(ofile); /* start record*/
  1279.     putstr(ofile, "stub-name", stub_name); /* stub name */
  1280. #ifdef IOT
  1281.     if (iot_ais_w == 1) printf(" writing out stub info\n");
  1282. #endif
  1283.  
  1284.     /* SCOPE STACKS */
  1285.     tup = (Tuple) ev->ev_scope_st;
  1286.     n = tup_size(tup);
  1287.     putnum(ofile, "scope-stack-size", n);
  1288.     for (i = 1; i <= n; i++) {
  1289.         tup2 = (Tuple) tup[i];
  1290.         putsymref(ofile, "scope-stack-symref", (Symbol) tup2[1]);
  1291.         for (j = 2; j <= 4; j++) {
  1292.             tup3 = (Tuple) tup2[j];
  1293.             m = tup_size(tup3);
  1294.             putnum(ofile, "scope-stack-m", m);
  1295.             for (k = 1; k <= m; k++)
  1296.                 putsymref(ofile, "scope-stack-m-symref", (Symbol) tup3[k]);
  1297.         }
  1298.     }
  1299.     putsymref(ofile, "ev-unit-name-symref", ev->ev_unit_unam);
  1300.     putdcl(ofile, ev->ev_decmap);
  1301.  
  1302.     /* unit_nodes */
  1303.     tup = ev->ev_nodes;
  1304.     n = tup_size(tup);
  1305.     putnum(ofile, "ev-nodes-size", n);
  1306. #ifdef IOT
  1307.     if (iot_ais_w) printf("unit_nodes %d\n", n);
  1308. #endif
  1309.     for (i = 1; i <= n; i++) {
  1310.         putnodref(ofile, "ev-nodes-nodref", (Node) tup[i]);
  1311. #ifdef IOT
  1312.         if (iot_ais_w) printf("    node %d %d\n",
  1313.             N_SEQ((Node)tup[i]), N_UNIT((Node)tup[i]));
  1314. #endif
  1315.     }
  1316.  
  1317.     /* context */
  1318.     tup = (Tuple) ev->ev_context;
  1319.     if (tup == (Tuple)0)
  1320.         n = 0;
  1321.     else
  1322.         n = tup_size(tup)+1;
  1323. #ifdef IOT
  1324.     if (iot_ais_w) printf("stub context size %d\n", n);
  1325. #endif
  1326.     putnum(ofile, "stub-context-size", n);
  1327.     if (n>1) {
  1328.         n -= 1;
  1329.         for (i = 1; i <= n; i++) {
  1330.             cent = (Tuple) tup[i];
  1331. #ifdef IOT
  1332.             if (iot_ais_w)printf("context %d %d %s\n", i, cent[1], cent[2]);
  1333. #endif
  1334.             putnum(ofile, "stub-cent-1", (int) cent[1]);
  1335.             cntup = (Tuple) cent[2]; /* 2nd component is tuple of strings */
  1336.             cn = tup_size(cntup);
  1337.             putnum(ofile, "stub-cent-2-size", cn);
  1338.             for (ci = 1; ci <= cn; ci++)
  1339.                 putstr(ofile, "stub-cent-2-str", cntup[ci]);
  1340.         }
  1341.     }
  1342.     /* tuple of symbol table pointers */
  1343.     tup = ev->ev_open_decls;
  1344.     if (tup == (Tuple)0)
  1345.         n = 0;
  1346.     else
  1347.         n = tup_size(tup)+1;
  1348.     putnum(ofile, "ev-decls-ref-size", n);
  1349.     /* write symbol table references so that they can be read by routine 
  1350.      * read_stub_short bypassing reading of full symbol definitions 
  1351.      */
  1352. #ifdef IOT
  1353.     if (iot_ais_w) printf(" decls-ref %d\n", n);
  1354. #endif
  1355.     if (n>1) {
  1356.         n -= 1;
  1357.         for (i = 1; i <= n; i++) {
  1358.             /* write symbol ref */
  1359.             putsymref(ofile, "decls-ref", (Symbol) tup[i]);
  1360. #ifdef IOT
  1361.             if (iot_ais_w)
  1362.                 printf(" symbol %d %d\n", S_SEQ((Symbol)tup[i]),
  1363.                   S_UNIT((Symbol)tup[i]));
  1364. #endif
  1365.         }
  1366.     }
  1367.     /* tuple of symbol table pointers */
  1368.     tup = ev->ev_open_decls;
  1369.     if (tup == (Tuple)0)
  1370.         n = 0;
  1371.     else
  1372.         n = tup_size(tup)+1;
  1373.     putnum(ofile, "ev-open-decls-size", n);
  1374. #ifdef IOT
  1375.     if (iot_ais_w) printf(" open_decls %d\n", n);
  1376. #endif
  1377.     if (n>1) {
  1378.         n -= 1;
  1379.         for (i = 1; i <= n; i++) {
  1380.             /*putsymref(ofile, tup[i]);*/
  1381.             /* write full symbol def */
  1382.             putsym(ofile, "open-decls-sym", (Symbol) tup[i]);
  1383. #ifdef IOT
  1384.             if (iot_ais_w)
  1385.                 printf(" symbol %d %d\n", S_SEQ((Symbol)tup[i]),
  1386.                   S_UNIT((Symbol)tup[i]));
  1387. #endif
  1388.         }
  1389.     }
  1390.     putnum(ofile, "stub-current-level", ev->ev_current_level);
  1391.     tup = (Tuple) ev->ev_relay_set;
  1392.     if (tup == (Tuple)0)
  1393.         n = 0;
  1394.     else
  1395.         n = tup_size(tup)+1;
  1396.     putnum(ofile, "ev-stub-relay_set-size", n);
  1397. #ifdef IOT
  1398.     if (ofile->fh_trace) printf(" relay_set %d\n", n);
  1399. #endif
  1400.     if (n>1) {
  1401.         n -= 1;
  1402.         for (i = 1; i <= n; i++) {
  1403.             putsymref(ofile, "relay_set_sym", (Symbol) tup[i]);
  1404.             /* write ref to symbol  */
  1405. #ifdef IOT
  1406.             if (ofile->fh_trace)
  1407.                 printf(" symbol %d %d\n",
  1408.                     S_SEQ((Symbol)tup[i]), S_UNIT((Symbol)tup[i]));
  1409. #endif
  1410.         }
  1411.     }
  1412.     tup = (Tuple) ev->ev_dangling_relay_set;
  1413.     if (tup == (Tuple)0)
  1414.         n = 0;
  1415.     else
  1416.         n = tup_size(tup)+1;
  1417.     putnum(ofile, "ev-dangling_relay_set-size", n);
  1418. #ifdef IOT
  1419.     if (ofile->fh_trace) printf(" dangling_relay_set %d\n", n);
  1420. #endif
  1421.     if (n>1) {
  1422.         n -= 1;
  1423.         for (i = 1; i <= n; i++) {
  1424.             putnum(ofile, "dangl_relay_ent", (int) tup[i]);
  1425.         }
  1426.     }
  1427.     write_end(ofile, begpos);
  1428. }
  1429.  
  1430. void write_tre(int uindex, int rootseq, char *reach)            /*;write_tre*/
  1431. /* rootseq - sequence number of root node*/
  1432. /* uindex - unit number */
  1433. {
  1434.     long    *rara, dpos;
  1435.     int i, nodes;
  1436.     Node    node;
  1437.     Tuple    tup;
  1438.     long    begpos;
  1439.     IFILE    *ofile;
  1440.     struct unit *pUnit = pUnits[uindex];
  1441.  
  1442.     nodes = seq_node_n;
  1443.     /* save position of start of data */
  1444.     /* write out all nodes if reach is null ptr */
  1445.     ofile = TREFILE;
  1446.     begpos = write_next(ofile);
  1447.     putstr(ofile, "unit-name", pUnit->name); /* unit name */
  1448.     putnum(ofile, "unit-number", uindex); /* unit number */
  1449.     putnum(ofile, "node-count", nodes);
  1450.     pUnit->treInfo.nodeCount = nodes;
  1451.     /* allocate space for node directory and write to file, saving position*/
  1452.     rara = (long *)ecalloct((unsigned) nodes+1, sizeof(long), "write-tre-rara");
  1453.     dpos = iftell(ofile);
  1454. #ifdef HI_LEVEL_IO
  1455.     fwrite((char *) rara, sizeof(long), nodes+1, ofile->fh_file);
  1456. #else
  1457.     write(ofile->fh_file, (char *) rara, sizeof(long)*(nodes+1));
  1458. #endif
  1459.     putnum(ofile, "root-seq", rootseq);
  1460.     for (i = 1; i <= nodes; i++) {
  1461.         if (reach != (char *) 0 && reach[i] != '1') continue;
  1462.         node = (Node) seq_node[i];
  1463.         if (node == (Node)0) continue; /* do not write null nodes */
  1464.         rara[i] = iftell(ofile);
  1465.         putnod(ofile, "unit-node", node);
  1466.     }
  1467.     /* rewrite node list now that available */
  1468.     ifseek(ofile, "seek-node-list", dpos, 0);
  1469. #ifdef HI_LEVEL_IO
  1470.     fwrite((char *) rara, sizeof(long), nodes+1, ofile->fh_file);
  1471. #else
  1472.     write(ofile->fh_file, (char *) rara, sizeof(long)*(nodes+1));
  1473. #endif
  1474.     ifseek(ofile, "seek-to-end", 0l, 2); /* position back at end*/
  1475.     /* ????? pUnit->treInfo.tupleAllocated = (char *) rara; */
  1476.     /* save address of node list */
  1477.     tup = tup_new(nodes);
  1478.     for (i = 1; i <= nodes; i++)
  1479.         tup[i] = (char *) seq_node[i];
  1480.     pUnit->treInfo.tableAllocated = (char *) tup;
  1481.     write_end(ofile, begpos);
  1482. }
  1483.  
  1484. static long write_next(IFILE *ofile)                            /*;write_next*/
  1485. {
  1486.     long    startpos;
  1487.     ifseek(ofile, "write-next-seek-to-end", 0L, 2); /* move to end of file */
  1488.     startpos = iftell(ofile); /* note position */
  1489.     putlong(ofile, "start-next-unit", startpos);
  1490.     return startpos;
  1491. }
  1492.  
  1493. void write_end(IFILE *ofile, long startpos)            /*;write_end*/
  1494. {
  1495.     long pos;
  1496.  
  1497.     ifseek(ofile, "write-end-seek-to-end", 0L, 2); /*move to end of file */
  1498.     pos = iftell(ofile); /* get offset of end of file*/
  1499.     ofile->fh_units_end = pos;
  1500.     /* move to start of pointer word */
  1501.     ifseek(ofile, "write-end-seek-pointer", startpos, 0);
  1502.     /* update pointer to next record */
  1503.     putlong(ofile, "write-end-next-unit", pos);
  1504.     ifseek(ofile, "write-end-seek-to-end", 0L, 2); /* move to end of file */
  1505. }
  1506.  
  1507. static void put_unit_unam(IFILE *ofile, Symbol sym)            /*;put_unit_unam*/
  1508. {
  1509.     /*  
  1510.      * Write the full symbol definitions of the associated symbol field of the
  1511.      * unit name symbol. This is needed since when binding is done we want to
  1512.      * load the symbols from this field which represent the procedures to 
  1513.      * elaborate packages. If a filed entry is undefined we write out the
  1514.      * definition of the OPT_NAME symbol so that we always have 3 entries.
  1515.      */
  1516.  
  1517.     Tuple    tup;
  1518.     int    i;
  1519.  
  1520.     tup = ASSOCIATED_SYMBOLS(sym);
  1521.     if (tup == (Tuple)0) tup = tup_new(3);
  1522.     for (i = 1; i <= 3; i++) {
  1523.         if (tup[i] != (char *)0) putsym(ofile, "ud-assoc-sym", (Symbol)tup[i]);
  1524.         else putsym(ofile, "ud-assoc-sym", OPT_NAME);
  1525.     }
  1526. }
  1527.  
  1528. void cleanup_files()                                        /*;cleanup_files*/
  1529. {
  1530.     /* This procedure removes all files in the library that are not
  1531.      * attached to currently active compilation units.
  1532.      */
  1533. #ifdef BSD
  1534.     DIR *dirp;
  1535.     struct direct *dp;
  1536. #endif
  1537.  
  1538. #ifdef SYSTEM_V
  1539.     register int    fd;
  1540.     struct direct    entry;
  1541. #endif 
  1542.  
  1543. #ifdef IBM_PC
  1544.     char *emalloc();
  1545.     char *strjoin();
  1546.     char *dname;
  1547.     struct find_t dos_fileinfo;
  1548. #endif
  1549.  
  1550. #ifdef vms
  1551. #define FILE_NAME_LEN  65     /* length of string that will hold files found */
  1552. #define GOOD_DELETE_RC  0
  1553. #define BAD_DELETE_RC  -1
  1554.     char *strjoin();
  1555.     char *ifname();
  1556.     /* descriptors for dir. search */
  1557.     struct dsc$descriptor file_spec, result_spec;
  1558.     unsigned long context = 0;    /* context variable for directory search */
  1559.     char *string;            /* search string */
  1560.     char *end;            /* will point to the end of the filenames */
  1561.     unsigned long find_rc = RMS$_NORMAL;  /* LIB$FIND_FILE return code */
  1562.     int delete_rc = GOOD_DELETE_RC;    /* LIB$DELETE_FILE return code */
  1563. #endif
  1564.  
  1565.     char *s1,*s2;
  1566.     int  unit;
  1567.     Tuple active_files;
  1568.  
  1569.     /* create a list of active files (those for which there is at least
  1570.      * one non-obsolete unit in it.)
  1571.      */
  1572.     active_files = tup_new1(FILENAME);
  1573.  
  1574.     for (unit = 1; unit <= unit_numbers; unit++) {
  1575.         struct unit *pUnit = pUnits[unit];
  1576.            if (streq(pUnit->libInfo.obsolete, "ok")) {
  1577.              if (!tup_memstr(pUnit->libInfo.fname, active_files)) {
  1578.                 active_files = tup_with(active_files, pUnit->libInfo.fname);
  1579.             }
  1580.          }
  1581.     }
  1582.  
  1583. #ifdef BSD
  1584.     dirp = opendir(LIBRARY_PREFIX);
  1585.     /* Loop through the directory and remove any files of the form #.* if
  1586.      * # is not an active file.
  1587.      */
  1588.     for (dp = readdir(dirp); dp != NULL; dp = readdir(dirp)) {
  1589.            s1 = strjoin(dp->d_name,"");
  1590.            s2 = strchr(s1,'.');
  1591.            if (s2 == (char *)0) s2 = s1;
  1592.            *s2 = '\0';
  1593.            /* ignore files that don't have a dot in it. */
  1594.            if (!strlen(s1)) continue;
  1595.            /* only consider of files of the form xxx.yyy where yyy is one of the 
  1596.             * Ada/Ed extensions 
  1597.             */
  1598.            s2++; /* file extension */
  1599.            if ((streq(s2,"trc")|| streq(s2,"axq") || streq(s2,"st1")
  1600.           || streq(s2,"st2") || streq(s2,"exe"))
  1601.           && !tup_memstr(s1, active_files)) {
  1602.               ifdelete(dp->d_name);
  1603.            }
  1604.     }
  1605.  
  1606.     /* remove the current aic file */
  1607.     ifdelete(strjoin(AISFILENAME,".aic"));
  1608.  
  1609. #endif
  1610. #ifdef SYSTEM_V
  1611.     fd = open(LIBRARY_PREFIX,O_RDONLY);
  1612.     /* Loop through the directory and remove any files of the form #.* if
  1613.      * # is not an active file.
  1614.      */
  1615.     while (read(fd,&entry,sizeof(entry)) > 0) {
  1616.            if (entry.d_ino == 0) continue;
  1617.            s1 = strjoin(entry.d_name, "");
  1618.            s2 = strchr(s1,'.');
  1619.            if (s2 == (char *)0) s2 = s1;
  1620.            *s2 = '\0';
  1621.            /* ignore files that don't have a dot in it. */
  1622.            if (!strlen(s1)) continue;
  1623.            /* only consider of files of the form xxx.yyy where yyy is one of the 
  1624.             * Ada/Ed extensions 
  1625.             */
  1626.            s2++; /* file extension */
  1627.            if ((streq(s2, "trc")|| streq(s2, "axq") || streq(s2, "st1")
  1628.           || streq(s2, "st2")) && !tup_memstr(s1, active_files)) {
  1629.               ifdelete(entry.d_name);
  1630.            }
  1631.     }
  1632.  
  1633.     /* remove the current aic file */
  1634.     ifdelete(strjoin(AISFILENAME, ".aic"));
  1635. #endif
  1636. #ifdef IBM_PC
  1637.     /* Loop through the directory and remove any files of the form #.* if
  1638.      * # is not an active file.
  1639.      */
  1640.     errno = 0;
  1641.  
  1642.     dname = emalloc(strlen(LIBRARY_PREFIX) + 5);
  1643.     strcpy(dname, LIBRARY_PREFIX);
  1644.     strcat(dname,"\\*.*");
  1645.     for (_dos_findfirst(dname, _A_NORMAL, &dos_fileinfo);;
  1646.       _dos_findnext(&dos_fileinfo)) {
  1647.         if (errno) break;
  1648.         s1 = strjoin(dos_fileinfo.name, "");
  1649.         s2 = strchr(s1, '.');
  1650.         if (s2 == (char *)0) s2 = s1;
  1651.         *s2 = '\0';
  1652.         /* ignore files that don't have a dot in it. */
  1653.         if (!strlen(s1)) continue;
  1654.         /* only consider of files of the form xxx.yyy where yyy is one of the 
  1655.          * Ada/Ed extensions 
  1656.          */
  1657.         s2++; /* file extension */
  1658.         /* On PC, directory folds file names to upper case */
  1659.         if ((streq(s2, "TRC")|| streq(s2, "AXQ") ||streq(s2, "ST1")
  1660.           || streq(s2, "ST2")) && !tup_memstr(s1, active_files)) {
  1661.             ifdelete(dos_fileinfo.name);
  1662.         }
  1663.     }
  1664.  
  1665.     /* remove the current aic file */
  1666.     ifdelete(strjoin(AISFILENAME, ".AIC"));
  1667. #endif
  1668.  
  1669. #ifdef vms
  1670.     /* Initialize descriptors for the search filename and the descriptor that
  1671.      * will hold the found filename.
  1672.      */
  1673.  
  1674.       string = ifname("*", "*");
  1675.       file_spec.dsc$w_length =  strlen(string);
  1676.       file_spec.dsc$b_dtype = DSC$K_DTYPE_T; 
  1677.       file_spec.dsc$b_class = DSC$K_CLASS_S;
  1678.       file_spec.dsc$a_pointer = string;
  1679.       result_spec.dsc$w_length =  FILE_NAME_LEN;
  1680.       result_spec.dsc$b_dtype = DSC$K_DTYPE_T; 
  1681.       result_spec.dsc$b_class = DSC$K_CLASS_S;
  1682.       result_spec.dsc$a_pointer = malloc(FILE_NAME_LEN);
  1683.  
  1684.     /* Loop through the directory and remove any files of the form #.* if #
  1685.      * is not an active file and * is one of the Ada/Ed extensions.
  1686.      */
  1687.       while  ((find_rc == RMS$_NORMAL) && (delete_rc == GOOD_DELETE_RC))  {
  1688.          find_rc = LIB$FIND_FILE(&file_spec, &result_spec, &context);
  1689.          if  (find_rc == RMS$_NORMAL)  {
  1690.             s1 = strjoin(result_spec.dsc$a_pointer, "");
  1691.             s1 = strchr(s1, ']');
  1692.             s1++;        /* Get to beginning of filename */
  1693.             end = strchr(s1, ';');
  1694.             *end = '\0';    /* insert end of string after filename */
  1695.             s2 = strchr(s1, '.');
  1696.             *s2 = '\0';    /* remove extension */
  1697.             s2++;        /* s2 is the extension */
  1698.             if  ((streq(s2, "TRC") || streq(s2, "AXQ") || streq(s2, "ST1")
  1699.               || streq(s2, "ST2")) && !tup_memstr(s1, active_files)) {
  1700.                 delete_rc = delete(result_spec.dsc$a_pointer);
  1701.             }
  1702.       }
  1703.        }
  1704.    LIB$FIND_FILE_END(&context);
  1705.  
  1706.     /* remove the current aic file */
  1707.    ifdelete(strjoin(AISFILENAME, ".AIC"));
  1708. #endif
  1709. }
  1710.  
  1711. void ifdelete(char *fname)                                        /*;ifdelete*/
  1712. {
  1713.     char *tname;
  1714. #ifdef vms
  1715.     char *DIRECTORY_START = "[.";
  1716. #endif
  1717.  
  1718.     /* allow room for library prefix, file name and suffix */
  1719.     tname = emalloc((unsigned) (strlen(LIBRARY_PREFIX) + strlen(fname) + 3));
  1720.     if (strlen(LIBRARY_PREFIX)) { /* prepend library prefix if present */
  1721. #ifdef vms
  1722.         if (strchr(LIBRARY_PREFIX, '[')) {
  1723.             strcpy(tname, LIBRARY_PREFIX);
  1724.         }
  1725.         else {
  1726.             strcpy(tname, DIRECTORY_START);
  1727.             strcat(tname, LIBRARY_PREFIX);
  1728.         }
  1729. #else
  1730.         strcpy(tname, LIBRARY_PREFIX);
  1731. #endif
  1732. #ifdef IBM_PC
  1733.         strcat(tname, "\\");
  1734. #endif
  1735. #ifdef BSD
  1736.         strcat(tname, "/");
  1737. #endif
  1738. #ifdef SYSTEM_V
  1739.         strcat(tname, "/");
  1740. #endif
  1741. #ifdef vms
  1742.         if (!strchr(LIBRARY_PREFIX, '['))
  1743.             strcat(tname, "]");
  1744. #endif
  1745.         strcat(tname, fname);
  1746.     }
  1747.     else {
  1748.         strcpy(tname, fname); /* copy name if no prefix */
  1749.     }
  1750. #ifdef BSD
  1751.     unlink(tname);
  1752. #endif
  1753. #ifdef SYSTEM_V
  1754.     unlink(tname);
  1755. #endif
  1756. #ifdef IBM_PC
  1757.     unlink(tname);
  1758. #endif
  1759. #ifdef vms
  1760.     delete(tname);
  1761. #endif
  1762.     efree(tname);
  1763. }
  1764.